Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/mdishe/database.bas

BASIC Source File | 1994-12-29 | 8.3 KB | 276 lines

' ********************************************************
'        MDI Standard Application Shell
' ********************************************************
'
' SUMMARY
' -------
' This file is part of an MDI application "skeleton"
' created by John Blessing of Leigh Business Enterprises Ltd.
'
' FEATURES
' --------
' Selection of application database.
' Compact/Repair of database.
' 'Helptips' on toolbar items.
' Support for Help files.
' MDI child forms tiling etc.
' Error trapping.
' 'Nag' screen support for shareware authors.
' Support for 3D dialogs (switched off in design mode
'   to prevent GPFs)
'
' USE
' ---
' You need VB Pro to use this shell, although it could be
' modified to run under the standard edition.
'
' You will need to set up some information in APP.BAS,
' particularly in SetAppInfo().  You will also need to add
' your own application specific code to this module.
'
' DISTRIBUTION
' ------------
' This program is "FreeWare" and may be used and distributed
' as you wish.
'
' It incorporates some ideas/code from other authors and these
' are acknowledged in the appropriate module.
'
' We hope that you will find it useful.  If you wish to discuss it
' then please e-mail us on Compuserve 100444,623.
'
' ADVERTISEMENT!
' --------------
' Are you looking for a helpdesk system? Or does your company
' want to track and monitor the progress of any work activity?
' We market a system which could be of interest to you.
'
' PROGRESS is available for download from the Business section
' of the Windows Shareware forum on Compuserve
' (filename PRGRSS10.ZIP).  It's a large program, so in the
' same section you will also find the help files and
' documentation as  PRGSSDOC.ZIP which is quicker to download
' and will give you a good idea of the functionality of PROGRESS.
'
' Dec 1994
Option Explicit

'======================================================================
'Form/Module:
'   Database.bas
'
'Procedure:
'   CompactDbase
'
'Parameters:
'   cmdialog    The common dialog to be used for selection of the file
'
'Returns:
'   None
'
'Modifications:
'   26/12/94   JBL     Build
'
'Description:
'   Compacts an Access database
'======================================================================
'
Sub CompactDbase (cmdialog As CommonDialog)

    Dim sDbase, sBakDb         As String
    Dim db                  As Database

    On Error Resume Next

    sDbase = sSelectDbase(cmdialog, "Compact")
    If sDbase <> "" Then

        screen.MousePointer = HOURGLASS

        'try and open it in exclusive mode
        Set db = OpenDatabase(sDbase, True)
        If Err = 0 Then
            'opened ok so close it
            db.Close

            'construct the correct .bak filename
            sBakDb = Left$(sDbase, InStr(sDbase, ".")) & "BAK"

            'give a chance to exit
            If MsgBox("Your existing " & sDbase & sGNl & "will be copied to " & sBakDb, MB_OKCANCEL + MB_ICONEXCLAMATION, "Compact database") = IDCANCEL Then
                screen.MousePointer = DEFAULT
                Exit Sub
            End If

            'kill any existing .bak
            Kill sBakDb
            If Err <> 0 Then Err = 0'err because no existing .bak

            'copy original to sBakdb
            FileCopy sDbase, sBakDb
            If Err <> 0 Then
                'call the generic error handler
                GenErrorHandler "Database.bas - CompactDbase()", Err, Error$ & sGNl & "Please try later when no one else is using the system."
                screen.MousePointer = DEFAULT
                Exit Sub
            End If

            'kill the existing database because can't compact into an existing one
            Kill sDbase
            DoEvents
            If Err = 0 Then
                'deleted ok so compact it
                CompactDatabase sBakDb, sDbase
                If Err <> 0 Then
                    'call the generic error handler
                    GenErrorHandler "Database.bas - CompactDbase()", Err, Error$
                    'copy bakdb to original
                    FileCopy sBakDb, sDbase
                    If Err <> 0 Then
                        'call the generic error handler
                        GenErrorHandler "Database.bas - CompactDbase()", Err, Error$
                        screen.MousePointer = DEFAULT
                        Exit Sub
                    End If
                End If
            End If
            MsgBox "Compact completed."
        Else
            'call the generic error handler
            GenErrorHandler "Database.BAS - CompactDbase()", Err, Error$ & sGNl & "Please try later when no one else is using the system."
        End If
    End If


    screen.MousePointer = DEFAULT

End Sub

'======================================================================
'Form/Module:
'   Database.bas
'
'Procedure:
'   RepairDbase
'
'Parameters:
'   cmdialog    The common dialog to be used for selection of the file
'
'Returns:
'   None
'
'Modifications:
'   26/12/94   JBL     Build
'
'Description:
'   Repairs an Access database
'======================================================================
'
Sub RepairDbase (cmdialog As CommonDialog)
    Dim sDbase  As String
    Dim db      As Database

    On Error Resume Next

    sDbase = sSelectDbase(cmdialog, "Repair")
    If sDbase <> "" Then

        screen.MousePointer = HOURGLASS

        'try and open it in exclusive mode
        Set db = OpenDatabase(sDbase, True)
        If Err = 0 Then
            'opened ok so close it
            db.Close
            DoEvents
            'repair it
            RepairDatabase sDbase
            If Err = 0 Then
                MsgBox "Repair completed successfully."
            Else
                'call the generic error handler
                GenErrorHandler "Database.bas - RepairDbase()", Err, Error$ & sGNl & "Please try later when no one else is using the system."
            End If
        Else
            'call the generic error handler
            GenErrorHandler "Database.BAS - RepairDbase()", Err, Error$ & sGNl & "Please try later when no one else is using the system."
        End If
    End If

    screen.MousePointer = DEFAULT


End Sub

'======================================================================
'Form/Module:
'   Database.bas
'
'Procedure:
'   sSelectDbase
'
'Parameters
'   cmdialog       the control used to select the filename
'   sMode           either NEW, OPEN, REPAIR or COMPACT
'
'Returns
'   The name of the selected file or empty string
'
'Modifications:
'   26/12/94   JBL     Build
'
'Description:
'   Creates a new Access database then opens it
'======================================================================
Function sSelectDbase (cmdialog As CommonDialog, sMode As String) As String
    Dim db  As Database

    On Error Resume Next


    sMode = UCase$(sMode)

    'set up the common dialog control
    cmdialog.DefaultExt = "mdb"
    cmdialog.Filename = ""
    cmdialog.CancelError = True
    cmdialog.Filter = "Database (*.mdb)|*.mdb|All files (*.*)|*.*|"
    cmdialog.Flags = &H4& Or &H1000& 'remove readonly checkbox

    Select Case sMode
    Case "NEW"
        cmdialog.DialogTitle = "New Database"
        cmdialog.Action = 2
    Case "OPEN"
        cmdialog.DialogTitle = "Open Database"
        cmdialog.Action = 1
    Case "REPAIR"
        cmdialog.DialogTitle = "Repair Database"
        cmdialog.Action = 1
    Case "COMPACT"
        cmdialog.DialogTitle = "Compact Database"
        cmdialog.Action = 1
    End Select

    If Err <> 32755 Then    'i.e not cancel
        sSelectDbase = cmdialog.Filename
        If sMode <> "NEW" Then
            'don't try and open if one doesn't exist
            Set db = OpenDatabase(cmdialog.Filename, True)
            If Err = 0 Then
                'opened OK so return the filename
                sSelectDbase = cmdialog.Filename
            Else
                'not a valid access database
                GenErrorHandler "Database.bas - sSelectDbase()", Err, Error$
                sSelectDbase = ""
            End If
        End If
    Else
        'selected cancel
        sSelectDbase = ""
    End If

End Function